unit NeuroNets;

{$MINENUMSIZE 2}
{$POINTERMATH ON}

interface

uses
  Windows, Classes, SysUtils, Math;

type
  // == Base classes ===========================================================

  TPointer<T> = record
    type P = ^T;
  end;

  TBlocks<T> = record
  public type
    PBlock = ^TBlock;
    TBlock = record
      Next: PBlock;
      Size: Integer; // Fast access.
      Data: array of T;
    end;
  private
    class var
      FCache: PBlock;
    var
      FBlocks: PBlock;

    class destructor Destroy;
  public
    function  New(ASize: Integer): PBlock;
    procedure DisposeAll;
    property  Blocks: PBlock read FBlocks;
  end;

  TAllocator<T> = record
  public type
    P = ^T;
  private
    FNext:   P;
    FEOf:    P;
    FBlocks: TBlocks<T>;

    procedure Grow;
  public
    function  New: P; inline;
    procedure DisposeAll;
  end;

  // == TNeuroNet ==============================================================

  PValueArray = ^TValueArray;
  TValueArray = array[0..1024] of Double;
  TExecute    = procedure;

  PNeuroNet = ^TNeuroNet;
  TNeuroNet = record
  private
    FCode:    TBlocks<Byte>;
    FData:    TBlocks<Double>;
    FInputs:  PValueArray;
    FOutputs: PValueArray;
    FExecute: TExecute;
  public
    class procedure Sigmoid(var V: Double); static;

    procedure DisposeAll;
    property  Execute: TExecute read FExecute;
    property  Inputs: PValueArray read FInputs;
    property  Outputs: PValueArray read FOutputs;
  end;

  // == TNetBuilder ============================================================

  TNetBuilder = class
  public type
    PNode       = ^TNode;
    PConnection = ^TConnection;

    TNodeState = set of (nsInput, nsOutput, nsCompiling);
    TNode      = record
      State:    TNodeState;
      Inputs:   PConnection;
      Bias:     Double;
      Value:    PDouble;
      NextOut:  PNode;
    end;

    TConnection = record
      NextInput:  PConnection;
      From:       PNode;
      Weight:     Double;
    end;
  private
    FNodes:       TAllocator<TNode>;
    FConns:       TAllocator<TConnection>;
    FInputs:      PNode;
    FInputCount:  Integer;
    FOutputs:     PNode;
    FOutputCount: Integer;
    FNet:         PNeuroNet;
    FData:        PDouble;
    FDataEOf:     PDouble;
    FCode:        PByte;
    FCodeEOf:     PByte;

    procedure GrowData;
    procedure GrowCode;
    function  AllocData: PDouble; inline;
    function  Emit<T>: TPointer<T>.P; inline;
    function  EmitSlow<T>: TPointer<T>.P;
    procedure CompileNodes;
    procedure CompileNode(ANode: PNode);
  public
    destructor Destroy; override;

    function  AddInput: PNode;
    function  AddNode(ABias: Double): PNode;
    function  AddOutput(ABias: Double): PNode;
    function  AddConnection(AFrom, ATo: PNode; AWeight: Double): PConnection;
    procedure Compile(out ANet: TNeuroNet);
  end;

implementation

{ TNetBuilder }

function TNetBuilder.AddConnection(AFrom, ATo: PNode;
  AWeight: Double): PConnection;
begin
  Result           := Pointer(FConns.New);
  Result.From      := AFrom;
  Result.Weight    := AWeight;
  Result.NextInput := ATo.Inputs; // Add connection to
  ATo.Inputs       := Result;     // Inputs linked list.
end;

function TNetBuilder.AddNode(ABias: Double): PNode;
begin
  Result        := Pointer(FNodes.New);
  Result.State  := [];
  Result.Inputs := nil;
  Result.Bias   := ABias;
  Result.Value  := nil;
end;

destructor TNetBuilder.Destroy;
begin
  FNodes.DisposeAll;
  FConns.DisposeAll;
  inherited;
end;

function TNetBuilder.Emit<T>: TPointer<T>.P;
begin
  Result := Pointer(FCode);
  Inc(FCode, SizeOf(T));

  if FCode > FCodeEOf then
    Result := EmitSlow<T>;
end;

function TNetBuilder.EmitSlow<T>: TPointer<T>.P;
begin
  Dec(FCode, SizeOf(T));
  GrowCode;

  Result := Pointer(FCode);
  Inc(FCode, SizeOf(T));
end;

procedure TNetBuilder.GrowCode;
type
  JMP = packed record
    JMP:     Byte;
    JMP_OFF: NativeInt; // Signed.
  end;
var
  b:    TBlocks<Byte>.PBlock;
  prev: PByte;
begin
  prev     := FCode;
  b        := FNet.FCode.New(128);
  FCode    := @b.Data[0];
  FCodeEOf := FCode + b.Size - SizeOf(JMP);

  if prev = nil then
    FNet.FExecute := Pointer(FCode)
  else
    with JMP(Pointer(prev)^) do
    begin
      JMP     := $E9;
      JMP_OFF := NativeInt(FCode) - NativeInt(@JMP_OFF) -
                 SizeOf(Pointer);
    end;
end;

procedure TNetBuilder.GrowData;
var
  b: TBlocks<Double>.PBlock;
begin
  b        := FNet.FData.New(16);
  FData    := @b.Data[0];
  FDataEOf := FData + b.Size;
end;

procedure TNetBuilder.CompileNode(ANode: PNode);
type
  FLD = packed record
    FLD:       Word;
    FLD_VAL:   PDouble;
  end;
  FLD_MUL_ADD  = packed record
    FLD:       Word;
    FLD_VAL:   PDouble;
    FMUL:      Word;
    FMUL_VAL:  PDouble;
    FADDP:     Word;
  end;
  STP_WAIT_SIGMD = packed record
    FSTP:      Word;
    FSTP_VAL:  PDouble;
    WAIT:      Byte;
    MOV:       Byte;
    MOV_VAL:   Pointer;
    CALL:      Byte;
    CALL_OFF:  NativeInt; // Signed.
  end;
  MOV_64 = packed record
    FILD:      Word;
    FILD_VAL:  Pointer;
    FISTP:     Word;
    FISTP_VAL: Pointer;
  end;
var
  inp: PConnection;
  nd:  PNode;
begin
  Include(ANode.State, nsCompiling);

  { Process dependencies }

  inp := ANode.Inputs;

  while inp <> nil do
  begin
    nd := inp.From;
    if not (nsCompiling in nd.State) then
      CompileNode(nd);
    inp := inp.NextInput;
  end;

  { Compile node }

  if ANode.Value = nil then
    ANode.Value := AllocData;

  if not (nsInput in ANode.State) then
  begin
    // Here we emit ASM code, which is equivalent to
    // the following:
    //    ANode.Value := ANode.Bias +
    //                   I1.From.Value * I1.Weight +
    //                   I2.From.Value * I2.Weight +
    //                   I3.From.Value * I3.Weight + ...;
    //    Sigmoid(ANode.Value);

    with Emit<FLD>^ do
    begin
      FLD      := $05DD; // FLD [ANode.Bias]
      FLD_VAL  := AllocData;
      FLD_VAL^ := ANode.Bias;
    end;

    inp := ANode.Inputs;

    while inp <> nil do
    begin
      with Emit<FLD_MUL_ADD>^ do
      begin
        FLD       := $05DD; // FLD [From.Value]
        FLD_VAL   := inp.From.Value;
        FMUL      := $0DDC; // FMUL [inp.Weight]
        FMUL_VAL  := AllocData;
        FMUL_VAL^ := inp.Weight;
        FADDP     := $C1DE; // FADDP ST(1)
      end;

      inp := inp.NextInput;
    end;

    with Emit<STP_WAIT_SIGMD>^ do
    begin
      FSTP      := $1DDD; // FSTP [ANode.Value]
      FSTP_VAL  := ANode.Value;
      WAIT      := $9B;   // WAIT
      MOV       := $B8;   // MOV EAX, [ANode.Value]
      MOV_VAL   := ANode.Value;
      CALL      := $E8;   // CALL Sigmoid
      CALL_OFF  := NativeInt(@TNeuroNet.Sigmoid) -
                   NativeInt(@CALL_OFF) - SizeOf(Pointer);
    end;
  end;
end;

function TNetBuilder.AddInput: PNode;
begin
  Result         := Pointer(FNodes.New);
  Result.State   := [nsInput];
  Result.Inputs  := nil;
  Result.NextOut := FInputs;
  FInputs        := Result;

  Inc(FInputCount);
end;

function TNetBuilder.AddOutput(ABias: Double): PNode;
begin
  Result         := Pointer(FNodes.New);
  Result.State   := [nsOutput];
  Result.Inputs  := nil;
  Result.Bias    := ABias;
  Result.NextOut := FOutputs;
  FOutputs       := Result;

  Inc(FOutputCount);
end;

function TNetBuilder.AllocData: PDouble;
begin
  if FData = FDataEOf then
    GrowData;
  Result := FData;
  Inc(FData);
end;

procedure TNetBuilder.Compile(out ANet: TNeuroNet);
const
  INIT_SLOTS_CNT = 16;
var
  nd:   PNode;
  iosz: Integer;
  cur:  PDouble;
begin
  FNet := @ANet;
  ANet := Default(TNeuroNet); // Zero mem.

  iosz := FInputCount + FOutputCount + INIT_SLOTS_CNT;
  cur  := PDouble(@ANet.FData.New(iosz).Data[0]) + iosz;

  Dec(cur, INIT_SLOTS_CNT);         // For performance resons we pre-allocate
  FData    := cur;                  // some extra room for non-IO nodes to
  FDataEOf := cur + INIT_SLOTS_CNT; // prevent distinct allocation operation
                                    // in small nets.
  { Assign outputs slots }

  nd := FOutputs; // Output list contains nodes
                  // in reverce order.
  repeat
    Dec(cur);
    nd.Value := cur;
    nd       := nd.NextOut;
  until (nd = nil);

  ANet.FOutputs := PValueArray(cur);

  { Assign input slots }

  nd := FInputs; // Input list contains nodes
                 // in reverce order.
  repeat
    Dec(cur);
    nd.Value := cur;
    nd       := nd.NextOut;
  until (nd = nil);

  ANet.FInputs := PValueArray(cur);

  { Process nodes }

  CompileNodes;
  Emit<Byte>^ := $C3; // RET
end;

procedure TNetBuilder.CompileNodes;
var
  nd: PNode;
begin
  nd := FOutputs;
  while nd <> nil do
  begin
    if not (nsCompiling in nd.State) then
      CompileNode(nd);
    nd := nd.NextOut;
  end;
end;

{ TAllocator<T> }

procedure TAllocator<T>.DisposeAll;
begin
  FBlocks.DisposeAll;
  FNext   := FEOf;
end;

procedure TAllocator<T>.Grow;
var
  b: TBlocks<T>.PBlock;
begin
  b     := FBlocks.New(32);
  FNext := @b.Data[0];
  FEOf  := FNext + b.Size;
end;

function TAllocator<T>.New: P;
begin
  if FNext = FEOf then
    Grow;
  Result := FNext;
  Inc(FNext);
end;

{ TBlocks<T> }

class destructor TBlocks<T>.Destroy;
var
  b, nxt: PBlock;
begin
  b := FCache;

  while b <> nil do
  begin
    nxt := b.Next;
    System.Dispose(b);

    b := nxt;
  end;
end;

procedure TBlocks<T>.DisposeAll;
var
  b: PBlock;
begin
  b := FBlocks;

  if b <> nil then
  begin
    while b.Next <> nil do // Find b.
      b := b.Next;         //

    b.Next  := FCache;
    FCache  := FBlocks;
    FBlocks := nil;
  end;
end;

function TBlocks<T>.New(ASize: Integer): PBlock;
begin
  if FCache <> nil then
  begin
    Result := FCache;
    FCache := FCache.Next;
  end
  else
  begin
    System.New(Result);
    Result.Size := 0;
  end;

  if Result.Size < ASize then
  begin
    SetLength(Result.Data, ASize);
    Result.Size := ASize;
  end;

  Result.Next := FBlocks;
  FBlocks     := Result;
end;

{ TNeuroNet }

procedure TNeuroNet.DisposeAll;
begin
  FData.DisposeAll;
  FCode.DisposeAll;
end;

class procedure TNeuroNet.Sigmoid(var V: Double);
type
  PLine = ^TLine;
  TLine = record
    A, B: Double;
  end;
const
  {$I Sigmoid.inc}
var
  ir:  Int64Rec absolute V;
  itm: PLine;
begin
  // Sigmoid function: F(X) = 2 / (1 + Exp(-4.9 * X)) - 1. Tests shows
  // that implemented piecewise approximation outperform direct calculation  
  // in ~4.85 times.

  itm := DATA[ir.Hi shr SHIFT_A] + ((ir.Hi shr SHIFT_B) and MASK_B);
  V   := itm.A * V + itm.B;
end;

end.

